perm filename NOTWRT.F4[MSS,LCS]12 blob sn#138807 filedate 1975-01-07 generic text, type T, neo UTF8
00200		SUBROUTINE NOTWRT
00300		IMPLICIT INTEGER(A-Q,S-Z)
00400		COMMON/DL/IXRX,M,AA /FONT/JFONT 
00500		COMMON/SCM/V(78),ISCR,LCNT,RSTF,LIST(200),REND
00600		DIMENSION RACNT(65),RDOT(7),XAC(7),RNOTE(22)
00700		REAL DIS,PWDS,CENTR,POS,STFF
00800		COMMON /STF/RSTFAC(-3/4),RSTJ3
00900		COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
01000		COMMON/PLTR/PLT,RHT,DIS /POSI/STFF(-3/4),JJ2,POS
01200		COMMON /NU/NUMQ(44),RNUMS(327),RACCI(22),NACCI(3)
01300	C   FOR NOTE DRAWING
01310		COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
01320		1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,J5X,RXX,JJJ,
01330		1 PUNCT,RDIS,RJ
01400		EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2))
01500		1,(R6,RJQ(4)),(J7,JQ(5)),(J8,JQ(6)),(J9,JQ(7)),(J10,JQ(8))
01600		1,(J11,JQ(9)),(J6,JQ(4)),(R5,RJQ(3)),(R11,RJQ(9))
01700		1,(R8,RJQ(6)),(R7,RJQ(5)),(RX,JRX),(RJZ,RJQ(20))
01800		DATA RACNT/4.0,1000.005,17.0,0.105, 8.0,1003.0, 7.014, 11.0
01900		1,13. ,1000. ,0.010,14.01,14. ,17. ,1001.018,7. ,13.018,27.,
02000		1 1004., 4.002, 6.004, 8.004,10.002,10., 8.102,6.102,4.
02100		1,32.0,1000.0,14.0,1007.007,7.107, 43.0,1012.01,11.006,9.003
02200		1, 7.001, 5.0, 9.002, 13.006, 15.01, 10.004, 13.009, 52.0,
02300		1 1002.008,3.003, 5.001, 8.0, 10.0, 13.001, 15.003, 16.008,
02305		1 65.,1106.104, 0.002, 6.104, 12.002, 18.104, 24.002, 24.003,
02307		1 18.103, 12.003, 6.103, 0.003, 106.103/
02310	     1 ,RNOTE/ 1000., 5.007, 11.007, 16., 11.107, 5.107, 0.0,
02340	     1 1000.0, 7.007, 14.0, 7.107, 0,  1000.107, 14.007,
02370	     1 1014.107,0.007, 1000.003,4.107,6.007,9.107,11.007,14.103/
02400		DATA RDOT/1000.0, 0.103, 1.0, 1.103, 2.0, 2.103,0/
02500		1 , R5/5.0/, R66/66.0/, R72/72.0/,R18/18.0/,RSTM/14.54/
02600		1 ,XAC/9,14,18,28,33,44,53/
02700	C   ALL DATA NUMS OVER 90 GIVE INVISIBLE VECTORS
02900		RST7=7.*RSTJ3
03200	
03300	CC1	CALL CENTX
03400	C   'CENTR' IS VERTICAL PLACEMENT
03510		RST3=3.*RSTJ3
03520		RSTX=RSTJ3
03560	C  FOR MINIS AT 245
03600		RMINI=RSTJ3
03700	C  OR SHOULD THIS ONLY BE IN NOTES, ETC?  15/9/72
03800	
04100		RINV=1
04200		IF(JA.EQ.1)GO TO 11
04400		IF(JA.EQ.6)GO TO 242
04700	
04750	C  NEXT IS FOR RESTS
04800		IF(J5.GT.1)R4=R4-2
04900	CC	RA=R4
05000		R7=R6*10.
05100	C  FOR DOTS
05200	202	CALL REST
05300		IF(J5.GT.1)GO TO 200
05400		IF(R7.EQ.0)RETURN
05900	201	RA=14
05950		R6=0
06000		IF(J5)RA=19
06100		R2=R2+RA*RSTJ3
06200		R4=8.+R4
06300		JA=6
06400		J5=7
06500	C   IF P6=1 THE REST IS DOTTED
06600		CALL CENTX
06650		GO TO 242
06700	200	J5=J5-1
06800	C  FOR MULTIPLE TAILS ON 16TH REST, ETC.
06900		R4=R4+2.
07000		CALL RJBX(4.3)
07100		GO TO 202
07200	
10200	29	RJX=R2
10300		RJY=CENTR+RSTJ3
10400	108	CALL RDRAW(1,7.0,RDOT,RMINI,RJX,RJY,RMINI)
10410	C    ****   ****    ***  ↑↑↑↑↑↑↑↑↑↑ THESE WERE RSTJ3 11/74
10500		IF(JA.EQ.1.OR.R7.GE.20.)GO TO 290
10600		RB=POS+52.*RSTJ3
10700		IF(RJY.NE.RB)GO TO 6241
10800	C   WHERE IS RB USED LATER?
10900		RJY=RJY-12*RSTJ3
11000		GO TO 108
11100	C  ABOVE FOR DOTS
11200	290	R7=R7-10.
11300		IF(R7.LT.10.)GO TO 1342
11400		RJX=RJX+RSTJ3*10.
11500		GO TO 108
11600	
11700	
11800	C  FOR LEDGER LINES
11900	70	J11=J4
12000	C   NOTE #
12100	170	RJW=R2-7.*RMINI
12200		RZ=R2+20.*RMINI
12300		IF(J11)GO TO 71
12400		JX=J11
12500		JRX=13
12600	C********* 18/9/72
12700		GO TO 711
12800	71	JX=-J11
12900		JRX=J11*2+3
13000	711	RX=POS-18*RSTJ3+RST7*JRX
13100	C********* 18/9/72
13200		IF(J6)RZ=RZ+2*RMINI
13300	C126	IF(PLT.EQ.-3)GO TO 1126
13400	C  FOR 2-PASS PLOTTING
13500	C   ******* ABOVE IS NOT USED, 15/9/72
13600	126	CALL LINX(RJW,RX,RZ,RX)
13700	1126	IF(JX.EQ.1)GO TO 1122
13800		RX=RX+RSTJ3*14.
13900		JX=JX-1
14000		GO TO 126
14200	1122	J9=-1
14300		GO TO 1121
14400	
14500	C  NOTES****
14600	11	JY=0
14610		IF(R6.EQ.0)GO TO 1015
14620		JY=IABS(J6)
14700		R6=ABS(AMOD(R6,1.0))*10.
14800	C   R6 WILL HAVE ACCENT CODE # (.7=DOT, ETC.)
14900	1015	L=IABS(J4)
15120	CC	RX4=R4
15140		RJAC=R2
15160	C   TO SAVE POS. OF NOTE FOR ACCENT
15510		RZTM=2.
15520		STEM=J5/10
15700		IF(L.LT.100)GO TO 1013
15800		IF(L.LT.200)GO TO 1012
15900		RZTM=0
16000		IF(L.GE.300)GO TO 1014
16010		KL=8
16100		RG=12.0
16200	C  FOR DIAMOND NOTES.
16300		GO TO 1017
16350	1014	IF(L.GE.400)GO TO 1016
16400		RJX=RMINI*7
16410	C  FOR "X" NOTES.
16500		KL=13
16600		RG=16.
16700		RB=CENTR+RJX
17000		IF(STEM.EQ.2)RB=CENTR-RJX
17100		GO TO 1017
17150	
17160	1016	RB=CENTR+R11*RST7
17165	C  FOR NO NOTE HEAD.  P11 CAN ADJUST SOURCE OF STEM.
17170		GO TO 1017
17180	
17200	1012	RMINI=.6*RSTJ3
17300	C  FOR RMINI NOTES
17400	1017	R4=AMOD(R4,100.)
17440	C  FOR MINI TAILS AND ACCIS. ETC.
17500	1013	J4=R4
17600		RJZ=R4
18000		IF(JY.LT.10.OR.JY.GE.30)GO TO 2221
18100	C P6 FOR HOMING TO RIGHT(10,30) OR LEFT(20) OF STEM(10,30=UP, 20=DOWN)
18200	C P6<0 = WHITE NOTE
18300		RQ=RSTM
18400		IF(J6)RQ=RQ+1.66
18500	C GETS WIDTH OF NOTE DISPLACEMENT
18600		IF(JY.EQ.20)RQ=-RQ
18700		R2=R2+RQ*RMINI
18800	2221	IF(J4.GT.1.AND.J4.LT.13)GO TO 1121
18850	
18860		IF(J9)GO TO 1121
18900	C   ARE THERE LEDGER LINES?  P9=-1 SUPPRESSES THEM.
19000		J11=(J4+1)/2-6
19100		IF(J11)J11=-((3-J4)/2)
19200		GO TO 170
19300	C  IF J6≠0 NOTE IS FILLED IN
19320	1121	IF(L.GE.400)GO TO 123
19360	C  JUMP IF NO NOTE HEAD
19400		IF(J6.GE.0.AND.L.LT.200)GO TO 125
19405		IF(L.GE.200)GO TO 1253
19407	C  FOR DIAMOND AND X NOTES.
19410		KL=1
19420		RG=7.
19430	C  FOR WHITE NOTES ON DPY.
19500		IF(PLT.GE.0.OR.L.GE.200)GO TO 1253
19805	2121	J5=15
19807		RG=RSTJ3
19808	C FIX THIS SOME DAY↓↓  SEE 1342+1!
19810	CCXX	IF(RMINI.NE.RSTJ3)RSTJ3=.7*RSTJ3
19820	CC	IF(J7.NE.R7)J5=6
19825		IF(MOD(J7,10).NE.0)J5=16
19830	C  1 ADDED TO P7 MAKES A WHOLE NOTE(6) INSTEAD OF HALF(5).
19832	C  THESE NOTES ARE IN CLEF4.  1/2=43   WHOLE=44
19835		JX4=J4
19837	C  SAVE IT FOR DOTS
19840		CALL DRWNT(RMINI)
19842		J4=JX4
19843	C  GET IT BACK
19845		RSTJ3=RG
19850	C  DRAWS GOOD NOTES ON PLOTTER -- NOT ON DPY.
19860	CC  DONE IN DRWNT	R7=J7
19870	C  TO RESET IT.
20200		GO TO 123
20300	1251	CALL NOIR(RMINI)
20310	C  FOR QUARTER NOTES ON PLOTTER.
20400		GO TO 123
20500	
20600	125	IF(PLT)GO TO 1251
20700		KL=17
20800		RG=22.
21300	C   ABOVE IS NEW NOTES ROUTINE
21310	1253	CALL RDRAW(KL,RG,RNOTE,RMINI,R2,CENTR,RMINI)
21400	
21500	123	R5=R5-J5
21600	C  R5=STEPS TO LEFT FOR ACCID. (.1=1 STEP)
21700		IF(STEM.EQ.0)GO TO 1242
21800		IF(L.LT.300)RB=CENTR+RZTM
21850	C************↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑ +2
21900	C  ≥300 IS FOR 'X' NOTES.
22000	128	J7=MOD(J7,10)
22100		RG=(J7-1)*14
22200		IF(RG)RG=0
22270		IF(R8.EQ.999)R8=0
22300		IF(R8.LT.999)GO TO 751
22375		R8=R8-1000.
22387		J10=1
22393	C  1000+ PUTS SLASH ON NOTE STEM
22500	751	RH=R8*RST7
22600	C  STEM EXTENSIONS ARE BY NOTE #S
22700		IF(STEM.NE.2)GO TO 1280
22800		RJX=R2
22900	C  FOR STEM DOWN (=2)
23000		RG=-RG-48.
23100		RH=-RH
23200		L=20
23300	CC	RJY=3.
23750		RB=RB-RZTM*2
23755	C  FOR TILT OF ORDINARY NOTES (NOT X OR DIAMOND)
23760	C************↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑ SEE 21800  12/74
23800		GO TO 129
23900	C  NEXT IS FOR STEM UP.
24000	1280	RJX=RSTM
24500		IF(J6.NE.0.AND.J6.NE.30)RJX=16.2
24600	C  FOR HALF NOTES
24700		RJX=RJX*RMINI+R2
24800		RG=RG+48.
24900		L=10
25000	CC	RJY=-3.
25200	129	RZ=CENTR+RH+RG*RMINI
25300		IF(RMINI.NE.RSTJ3)RJW=RJW*.6
25400		CALL LINX(RJX,RB,RJX,RZ)
25500	C  RB HERE IS CENTR (FOR 'X' NOTES OR NOT)
25600	227	J5=J5-L
25700	C   J5 HAS ACCID. # NOW
25800		IF(J7.EQ.0)GO TO 1242
25900	C   JUMP IF NO TAILS
25910		IF(STEM.NE.2)GO TO 1127
25920		R4=R4-3.7-R8
25930	C R4 IS USED IN SUBR. TAIL   - R8 IS STEM EXTENSION.
25940		RJW=-2
25950		RA=1.
25960		GO TO 127
25970	1127	RJW=2
25977	C  FOR VERT. SPACING OF MULTIPLE TAILS
25984		R4=R4-2+R8
25991	C  2 ABOVE AND 3.7 BEFORE ARE BECAUSE ORIG. POS. OF TAIL DRWING IS OFF.
25996		RA=-1.
25998		R8=0
25999	C  ↑↑↑↑↑↑ FOR SHIFT AT 246
26000	127	CALL TAIL(RJX,RA,RMINI)
26100	1028	J7=J7-1
26200		IF(J7.EQ.0)GO TO 327
26300		R4=R4+RJW
26400	C  MOVES CENTR UP OR DOWN FOR NEXT TAIL
26500		GO TO 127
26562	CC327	IF(R4.GE.RX4)RX4=R4+1
26570	327	IF(R4.GE.RJZ)RJZ=R4+1
26575	C  FOR TRILLS, ETC.
26600		IF(J10.EQ.0)GO TO 1242
26700		RJY=RZ-19*RSTJ3
26800		RZ=RZ-RSTJ3*4.
26900		IF(RA.LT.0)GO TO 1327
27000	C  NEXT IS FOR STEM DOWN SLASH
27100		RJY=RZ+23*RSTJ3
27200		RZ=RZ+RST7
27300	1327	RJX=RJX-RST7
27400		CALL LINX(RJX,RJY,RJX+17.*RSTJ3,RZ)
27500	C  FOR SLASH ON GRACE NOTE TAIL
27600	1242	IF(R7.LT.10.)GO TO 1342
27700	C  FOR DOTTED NOTE-- P7>9 
27800		RJX=RJAC+(22.+AMOD(R7,1.0)*59.6)*RMINI
27850	C***↑↑↑↑↑  WAS 24.  11/74
27900		RJY=CENTR+RSTJ3
28000		IF(JY.EQ.10.OR.JY.EQ.30)RJX=RJX+RSTM
28100	C  MOVES DOT TO LEFT
28200		IF(MOD(J4,2).EQ.0)GO TO 108
28300		RX=RST7
28400		IF(JY.GE.20)RX=-RX
28500	3342	RJY=RJY+RX
28600		GO TO 108
28700	C  JY=30= STEM UP, INTERVAL OF SECOND.
28710	1342	IF(R6.EQ.0.AND.J5.EQ.0)RETURN
28800		R2=R2-R5*59.6*RMINI
28900	C  TO SPACE OUT ACCIDS.
29000	CCXX	IF(RMINI.NE.RSTJ3)RSTJ3=.7*RSTJ3
29100	C   ↑↑↑↑		  ↑↑↑↑↑ WAS RMINI
29200	C********* 18/9/72
29300	242	IF(J5.GE.0)GO TO 2421
29400		RINV=-RINV
29500		J5=-J5
29600	C  NOW THAT 0 IS NOT USED FOR DOTS THE ABOVE 3 LINES COULD BE CHNGD
29700	C********** LAST # WAS 281?
29800	C b,#,NAT, ACC ∧, ACC >, FERMATA, DOT, REP MEAS., DASH
29900	CXX 11/74 2421	RH=14
29910	2421	J5X=-1
29920		JAX=JA
29960	C  USED AT 4241  FOR DOUBLE MARKS ON NOTES.
30000		IF(JA.EQ.6)GO TO 2423
30010		IF(J5.GT.3)GO TO 3121
30020	C  DBL FLT(4) AND DBL SHRP(5)  ALWAYS USE 'DRAW' ROUTINE.
30030		GO TO 211
30050	2423	RJZ=AMOD(R4,100.)
30075	C  FOR 'DRWNT' WHEN PLOTTING.
30100		CALL NOZERO(R6)
30200	C  R6=SIZE FACTOR  (P6)
30300		RMINI=RMINI*R6
30400		R6=0
30500		STEM=0
30600	C   FOR MISC. ITEMS
30700	210	IF(IABS(J4).LT.100)GO TO 1241
30710	CC210	IF(IABS(J4).LT.100)GO TO 3241
30800		J4=MOD(J4,100)
30900		RMINI=.7*RMINI
31000	CC3421	J5X=-1
31100	C FOR 2 MARKS AT ONCE.
31200	1241	IF(J5.GE.11)GO TO 28
31300		GO TO (211,211,211,28,28,222,249,60,27,27),J5
31400		RETURN
31500	C  ERROR TRAP (I.E. J5=0)
31510	C  FOR 1 OR 2 BAR REP SIGNS.
31555	60	CALL BREP(R2,RSTJ3)
31577		RETURN
31600	
31700	241	CALL LINES(R2,CENTR,3)
31800		GO TO 210
31805	
31900	
31910	211	IF(J5.EQ.0)GO TO 2422
31917	C  GETS BACK GOOD VERTICAL POS.
31920		IF(J5.GT.3)GO TO 222
31930	C  FOR 2-PASS PLOTTING (-2=THIN LINES, -3=HEAVY LINES)
31940		IF(PLT.OR.JFONT)GO TO 3121
31950		X=NACCI(J5)
31960		CALL RDRAW(X+1,RACCI(X),RACCI,RMINI,R2,CENTR,RMINI)
32000	2422	IF(R6.EQ.0)RETURN
32004		J5=(R6+.001)*100.
32010	CC	R4=RX4
32020		R4=RJZ
32100		R2=RJAC
32300	1249	IF(MOD(J5,10).GT.3)GO TO 249
32400		J5=J5/10
32500		IF(J5.GT.30)GO TO 1249
32600	C WHEN P1=1, EXTRACTS ACCENT NUMBERS FROM DECIMALS IN P6.
32700	249	IF(J5.GT.30)GO TO 28
32800		IF(J5.GT.10)GO TO 246
32850		IF(J5.EQ.0)RETURN
32900		IF(JA.NE.1)GO TO 250
33000	CXX 11/74	RH=8
33100		RB=14.
33200		IF((J5.NE.7.AND.J5.NE.9).OR.MOD(J4,2).EQ.0)GO TO 244
33300		IF((STEM.LE.1.AND.J4.LT.5).OR.((STEM.EQ.2.OR.STEM.EQ.0)
33400		1 .AND.J4.GT.9))GO TO 244
33500		RB=21
33600	C   PUTS ACCENT DOWN OR UP 1 SPACE. AVOIDS PUTTING DOT OR DASH ON LINE
33700	244	IF(STEM.EQ.1.OR.(STEM.EQ.0.AND.J4.LT.7))RB=-RB
33800	CC	IF(J5.NE.6)GO TO 245
33900	CC	IF(J4.LT.9.AND.STEM.EQ.2)GO TO 281
34000	CC	IF(J4.GT.4.AND.STEM.EQ.1)GO TO 252
34100	245	CENTR=CENTR+RB*RSTX
34200	250	IF(J5.GT.10.OR.J5.LT.6)GO TO 281
34300		JA=6
34400		IF(J5.NE.7)GO TO 253
34500	C   7=DOT
34600		RXX=R2
34700		R2=R2+6.7*RMINI
34800	C  CENTERS THE DOT
34900		GO TO 29
35000	253	IF(J5.EQ.9)GO TO 271
35100	C   9=DASH
35200	251	IF(RB.LT.0)RINV=-RINV
35300	C   FIX THIS!!!!  FOR BOWINGS, ETC.
35310	2222	IF(J5.NE.20)GO TO 2223
35320		JA=20
35330		R5=0
35340		J7=1
35350		CALL ALPHA
35360	C  FOR TRILL  -- J5=20
35370		RETURN
35380	2223	IF(J5.EQ.17.OR.J5.EQ.18)RINV=J5
35390	C  FOR MORD, INV.MORD
35400	222	CALL FERMTA(RINV)
35500		GO TO 5241
35600	252	RX=POS
35700	248	CENTR=RX
35800		GO TO 251
35900	246	IF(J5.LT.10)GO TO 245
36000		R4=R4+3
36100		IF(STEM.EQ.1)R4=R4+6.+R8
36200		IF(R4.LT.12.5)R4=12.5
36300		CALL CENTX
36400		IF(J5.EQ.26)GO TO 222
36500	C  26 IS NEW NUMB FOR FERMATA.
36700	28	IF(J5.LT.30)GO TO 281
36800		J5X=MOD(J5,10)
36900	C  J5X SAVES NEXT MARK.
37000		IF(J5X.LT.4)J5X=0
37100		J5=J5/10
37200		IF(J5.GT.30)RETURN
37300	C  WON'T READ 415 ETC. (CORRECT=154)
37400	C DOES BOTTOM MARK FIRST, THEN TOP.
37500		CALL EXCH(J5X,J5)
37600	C  PUTS UPBOW, DNBOW, ETC. ABOVE STACC., ETC.
37700		IF(JA.EQ.1)GO TO 249
37800		GO TO 1241
37900	281	X=1
37950		IF(J5.GT.16)GO TO 2222
37975	C  JUMP FOR MORD, INV.MORD, TRILL
38000		IF(J5.NE.4)GO TO 228
38100		X=5
38200		CALL RJBX(.5)
38300		GO TO 328
38400	228	IF(J5.GT.10)X=XAC(J5-10)
38500	C   X IS POINTER IN RACNT ARRAY
38600	328	RA=RMINI
38700	C   OR RSTJ3?
38800		IF(RINV.LT.0.OR.(STEM.EQ.1.AND.J5.EQ.4))RA=-RA
38850	C  ↓↓↓ X ↓↓↓ PICKS UP TYPO ERRORS
38900		IF(X.LT.54)CALL RDRAW(X+1,RACNT(X),RACNT,RA,R2,CENTR,RMINI)
39000	C              PTR, WDCNT, ARRAY,Y MULT,HOR ADD,VERT ADD, X,Y,MULT
39100	C  IN ARRAY, 33.012 WOULD BE X=33, Y=12.  101.123 IS X=-1, Y=-23.
39200		GO TO 5241
39300	4241	JJJ=J5
39400		J5=J5X
39500		J5X=-1
39600		IF(JAX.NE.1)GO TO 7241
39700		IF(J5.GT.10)GO TO 246
39800		IF(J5.EQ.7.AND.JJJ.NE.9)GO TO 249
39900	7241	RXX=8.5*RMINI
39950	C↑↑↑↑↑↑  11/74  WAS RH*
40000		IF(STEM.EQ.1)RXX=-RXX
40100		CENTR=CENTR+RXX
40200		IF(J5.EQ.26)J5=6
40300	C  TEMPORARY?? FIX
40400		GO TO 1241
40500	C >=5,  ∧=4
40600	27	R2=J2
40700	C  DASHES
40800	271	CALL LINX(R2,CENTR,R2+RMINI*14.,CENTR)
40850	C    ****   ****    ***  ↑↑↑↑↑↑↑↑↑↑ THIS WAS RSTJ3 11/74
40900	5241	IF(J5X.GT.0)GO TO 4241
41000	C J5X IS FOR DOUBLE MARKS.  (WHAT ABOUT DOT POSITION.)
41100		RETURN
41200	6241	R2=RXX
41300	C  RESET R2 AFTER A DOT.
41400		GO TO 5241
42010	3121	J5=J5+9
42015	C  SOON WILL HAVE DBL FLAT (4) AND DBL SHRP (5)
42020	C  TO DRAW GOOD ACCIS ON PLOTTER - NOT ON DPY.(IN CLEF4.DMD)
42030		CALL DRWNT(RMINI)
42040		GO TO 2422
50200		END